home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0164_Another Wormhole.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  3KB  |  162 lines
  1.  
  2. { Turbo Pascal version 7.0 directive settings }
  3. {$a+,b-,d+,e+,f-,g+,i+,l+,n-,o-,p-,q-,r-,s+,t-,v+,x+}
  4.  
  5. { if you have a 386 or better 'uncomment' the next line }
  6. {-$define cpu386}
  7.  
  8. program wormhole;
  9. { Asm-version of Wormhole, by Bas van Gaalen, Holland, PD }
  10. uses
  11.   crt;
  12. const
  13.   vidseg:word=$a000;
  14.   divd=128;
  15.   astep=6;
  16.   xst=4;
  17.   yst=5;
  18. var
  19.   sintab:array[0..449] of integer;
  20.   stab,ctab:array[0..255] of integer;
  21.   virscr:pointer;
  22.   virseg:word;
  23.   lstep:byte;
  24.  
  25. procedure setpal(col,r,g,b : byte); assembler;
  26. asm
  27.   mov dx,03c8h
  28.   mov al,col
  29.   out dx,al
  30.   inc dx
  31.   mov al,r
  32.   out dx,al
  33.   mov al,g
  34.   out dx,al
  35.   mov al,b
  36.   out dx,al
  37. end;
  38.  
  39. procedure drawpolar(xo,yo,r,a:word; c:byte; lvseg:word); assembler;
  40. asm
  41.   mov es,lvseg
  42.  
  43.   mov bx,a
  44.   add bx,a
  45.   mov cx,word ptr sintab[bx]
  46.   add bx,2*90
  47.   mov ax,word ptr sintab[bx]
  48.   mul r
  49.   mov bx,divd
  50.   xor dx,dx
  51.   cwd
  52.   idiv bx
  53.   add ax,xo
  54.   add ax,160
  55.   cmp ax,320
  56.   ja @out
  57.   mov si,ax
  58.  
  59.   mov ax,cx
  60.   mul r
  61.   mov bx,divd
  62.   xor dx,dx
  63.   cwd
  64.   idiv bx
  65.   add ax,yo
  66.   add ax,100
  67.   cmp ax,200
  68.   ja @out
  69.  
  70.   shl ax,6
  71.   mov di,ax
  72.   shl ax,2
  73.   add di,ax
  74.   add di,si
  75.   mov al,c
  76.   mov [es:di],al
  77.  @out:
  78. end;
  79.  
  80. procedure cls(lvseg:word); assembler;
  81. asm
  82.   mov es,[lvseg]
  83.   xor di,di
  84.   xor ax,ax
  85. {$ifdef cpu386}
  86.   mov cx,320*200/4
  87.   rep
  88.   db $66; stosw
  89. {$else}
  90.   mov cx,320*200/2
  91.   rep stosw
  92. {$endif}
  93. end;
  94.  
  95. procedure flip(src,dst:word); assembler;
  96. asm
  97.   push ds
  98.   mov ax,[dst]
  99.   mov es,ax
  100.   mov ax,[src]
  101.   mov ds,ax
  102.   xor si,si
  103.   xor di,di
  104. {$ifdef cpu386}
  105.   mov cx,320*200/4
  106.   rep
  107.   db $66; movsw
  108. {$else}
  109.   mov cx,320*200/2
  110.   rep movsw
  111. {$endif}
  112.   pop ds
  113. end;
  114.  
  115. procedure retrace; assembler;
  116. asm
  117.   mov dx,03dah
  118.  @vert1:
  119.   in al,dx
  120.   test al,8
  121.   jnz @vert1
  122.  @vert2:
  123.   in al,dx
  124.   test al,8
  125.   jz @vert2
  126. end;
  127.  
  128. var x,y,i,j:word; c:byte;
  129. begin
  130.   asm mov ax,13h; int 10h; end;
  131.   for i:=0 to 255 do begin
  132.     ctab[i]:=round(cos(pi*i/128)*60);
  133.     stab[i]:=round(sin(pi*i/128)*45);
  134.   end;
  135.   for i:=0 to 449 do sintab[i]:=round(sin(2*pi*i/360)*divd);
  136.   getmem(virscr,64000);
  137.   virseg:=seg(virscr^);
  138.   cls(virseg);
  139.   x:=30; y:=90;
  140.   repeat
  141.     {retrace;}
  142.     c:=22; lstep:=2; j:=10;
  143.     while j<220 do begin
  144.       i:=0;
  145.       while i<360 do begin
  146.         drawpolar(ctab[(x+(200-j)) mod 255],stab[(y+(200-j)) mod 255],j,i,c,virseg);
  147.         inc(i,astep);
  148.       end;
  149.       inc(j,lstep);
  150.       if (j mod 5)=0 then begin inc(lstep); inc(c); if c>31 then c:=22; end;
  151.     end;
  152.     x:=xst+x mod 255;
  153.     y:=yst+y mod 255;
  154.     flip(virseg,vidseg);
  155.     cls(virseg);
  156.   until keypressed;
  157.   while keypressed do readkey;
  158.   freemem(virscr,64000);
  159.   textmode(lastmode);
  160. end.
  161.  
  162.